home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga Collections: Amiga Public Domain Connection
/
APDC Disk #005 - Amiga Basic Programs (198x)(Amiga Public Domain Connection)(US)[WB].zip
/
APDC Disk #005 - Amiga Basic Programs (198x)(Amiga Public Domain Connection)(US)[WB].adf
/
DeluxeDraw
< prev
next >
Wrap
Text File
|
1988-03-13
|
22KB
|
679 lines
' DeluxeDraw
' By Rick Wirch
' This program can be found in the April issue of Amazing Computing
' PIM Publications, P.O. Box 869, Fall River, Mass. 02722 (617) 679-3109
' It is available on disk from the AMICUS Public Domain Library
'
' Allocate enough memory to save entire screen into an array
DEF FNArraySize& = 3+INT((BobRight+16)/16)*(BobBottom+1)*Depth
BobRight = 600: BobBottom = 187 : Depth = 4
Size& = FNArraySize& * 2
IF FRE(0) AND FRE(-1) < Size& THEN PRINT "Not enough memory":END
IF FRE(0) < Size& THEN
CLEAR,Size&+24000
DEF FNArraySize& = 3+INT((BobRight+16)/16)*(BobBottom+1)*Depth
END IF
'------------------------
DECLARE FUNCTION SetDrMd LIBRARY ' Set the Drawing Mode
DECLARE FUNCTION Move LIBRARY ' Move the Plotting Position
DECLARE FUNCTION Flood LIBRARY ' Flood Fill an Area
DEFINT a-z
Depth = 0
WHILE Depth < 2 OR Depth > 5
INPUT "Select number of bit planes (2-5) ", Depth
WEND
RES=0
IF Depth = 5 THEN
RES = 311
ELSE
WHILE RES=0
INPUT "Select resolution (Hi/Lo) ", C$
C$=LEFT$(C$,1)
IF C$="H" OR C$="h" THEN RES=631
IF C$="L" OR C$="l" THEN RES=311
WEND
END IF
DIM PAT1%(1),PAT2%(1),PCan!(31,3) : DIM BobArray(1)
RES2=RES/320 'For hi-res aspect ratio for circles
IF RES < 400 THEN scrmode = 1 ELSE scrmode = 2
SCREEN 1, scrmode*320, 200, Depth, scrmode
CLS
WINDOW 2,"DeluxeDraw by Rick Wirch",(0,0)-(RES,186),0,1
WINDOW OUTPUT 2
TRUE=-1: FALSE=0 'For convenience
IF Depth = 5 THEN COLBOX = 6 ELSE COLBOX = 10
FOR I=0 TO 15: PALETTE I, 6/15, 6/15, 6/15: NEXT
' Set colors for Paintbox
PCan!(0,0)= 6/15: PCan!(0,1)= 6/15: PCan!(0,2)= 6/15 'Dark grey
PCan!(1,0)= 0/15: PCan!(1,1)= 0/15: PCan!(1,2)= 0/15 'Black
PCan!(2,0)=10/15: PCan!(2,1)=10/15: PCan!(2,2)=10/15 'Light grey
PCan!(3,0)=15/15: PCan!(3,1)=15/15: PCan!(3,2)=15/15 'White
PCan!(4,0)=15/15: PCan!(4,1)= 9/15: PCan!(4,2)= 9/15 'Pink
PCan!(5,0)=15/15: PCan!(5,1)= 6/15: PCan!(5,2)= 6/15 'Light Red
PCan!(6,0)=15/15: PCan!(6,1)= 2/15: PCan!(6,2)= 2/15 'Red
PCan!(7,0)=12/15: PCan!(7,1)= 0/15: PCan!(7,2)= 14/15 'Purple
PCan!(8,0)= 7/15: PCan!(8,1)=13/15: PCan!(8,2)= 15/15 'Light Blue
PCan!(9,0)= 8/15: PCan!(9,1)= 8/15: PCan!(9,2)= 15/15 'Med. Blue
PCan!(10,0)= 4/15:PCan!(10,1)= 4/15:PCan!(10,2)=15/15 'Dark Blue
PCan!(11,0)= 0/15:PCan!(11,1)=14/15:PCan!(11,2)= 13/15 'Aqua
PCan!(12,0)= 8/15:PCan!(12,1)=12/15:PCan!(12,2)= 8/15 'Light Green
PCan!(13,0)= 4/15:PCan!(13,1)=12/15:PCan!(13,2)= 4/15 'Med. Green
PCan!(14,0)= 0/15:PCan!(14,1)=15/15:PCan!(14,2)= 0/15 'Dark Green
PCan!(15,0)=15/15:PCan!(15,1)=15/15:PCan!(15,2)= 2/15 'Yellow
PCan!(16,0)=0/15: PCan!(16,1)= 4/15: PCan!(16,2)= 4/15 'aquas
PCan!(17,0)=0/15: PCan!(17,1)= 6/15: PCan!(17,2)= 6/15
PCan!(18,0)=0/15: PCan!(18,1)= 8/15: PCan!(18,2)= 8/15
PCan!(19,0)=0/15: PCan!(19,1)=10/15: PCan!(19,2)= 10/15
PCan!(20,0)=0/15: PCan!(20,1)=12/15: PCan!(20,2)= 12/15
PCan!(21,0)=15/15: PCan!(21,1)=15/15: PCan!(21,2)= 2/15 'yellows
PCan!(22,0)=15/15: PCan!(22,1)=15/15: PCan!(22,2)= 4/15
PCan!(23,0)=15/15: PCan!(23,1)=15/15: PCan!(23,2)= 6/15
PCan!(24,0)=15/15: PCan!(24,1)=15/15: PCan!(24,2)= 8/15
PCan!(25,0)=15/15: PCan!(25,1)=15/15: PCan!(25,2)= 10/15
PCan!(26,0)=15/15: PCan!(26,1)=15/15: PCan!(26,2)= 12/15
PCan!(27,0)= 2/15: PCan!(27,1)= 15/15:PCan!(27,2)= 2/15 'greens
PCan!(28,0)= 4/15: PCan!(28,1)= 15/15:PCan!(28,2)= 4/15
PCan!(29,0)= 6/15: PCan!(29,1)= 15/15:PCan!(29,2)= 6/15
PCan!(30,0)= 8/15: PCan!(30,1)= 15/15:PCan!(30,2)= 8/15
PCan!(31,0)= 10/15:PCan!(31,1)= 15/15:PCan!(31,2)= 10/15
FOR I=0 TO 2^Depth-1: PALETTE I, PCan!( I,0), PCan!( I,1), PCan!( I,2): NEXT
LIBRARY "graphics.library"
RP& = WINDOW(8) ' Pointer to the Raster Port
W=WINDOW( 2): H=WINDOW(3): WWIDTH=W: HEIGHT=H
' Make color selection boxes
FOR Y=0 TO HEIGHT STEP COLBOX
COL = (Y\COLBOX)
IF COL <= 2^Depth-1 THEN
COLOR COL: LINE(0,Y)-(20,Y+COLBOX),,bf
LINE(0,Y)-(20,Y+COLBOX),1,b
END IF
NEXT
' Make style selection boxes
COLOR 1: FOR Y=0 TO 150 STEP 10
LINE(21,Y)-(45,Y+10),,b: NEXT
' Show brush widths
COLOR 2: REM OUTLINE 0:
LINE(29,1)-( 37,9)
AREA(26,11): AREA( 32,11): AREA( 40,19): AREA( 34,19) : AREAFILL
AREA(24,21): AREA( 34,21): AREA( 42,29): AREA( 32,29) : AREAFILL
AREA(22,31): AREA( 36,31): AREA( 44,39): AREA( 30,39) : AREAFILL
' Custom Brush
LINE(25,44)-(32,46),,bf: LINE(32,42)-(35,48),,bf: LINE(35,42)-(40,48),3,bf
' Lines radiating from a point
LINE(26,52)-(41,52): LINE(26,52)-( 39,55): LINE( 26,52)-(36,57)
LINE(26,52)-(31,59): PSET(26,52),3
' Area color/pattern fill
AREA(31,62): AREA( 38,65): AREA( 31,68): AREA( 24,65) : AREAFILL
COLOR 3: AREA( 39,65): AREA( 38,69): AREA( 40,69) : AREAFILL
' Sizeable circle
COLOR 2: CIRCLE(33,75),4:PSET(33,75),3
' Sizeable rectangle
LINE(25,82)-(40,88),,b: PSET(25,82),3: PSET(40,88),3
' Moveable line
LINE(26,95)-( 39,95): PSET(25,95),3: PSET(40,95),3
' Text onto bit map
CALL Move&( RP&, 29, 108): PRINT "T";
' Adjust a color
LINE(23,112)-(43,114),3,bf: LINE(23,112)-(43,114),1,b
LINE(23,114)-(43,116),3,bf: LINE(23,114)-(43,116),1,b
LINE(23,116)-(43,118),3,bf: LINE(23,116)-(43,118),1,b
' Set/reset pattern
PAT1%(0)=&HFFFF: PAT1%(1)=&HFFFF
PAT2%(0)=&HAAAA: PAT2%(1)=&H5555
PATTERN ,PAT2%
COLOR 1,2: LINE(22,121)-(44,129),,bf
PATTERN ,PAT1%: Dotty=FALSE
' Color cycle
FOR I=3 TO 13: COL=I: IF COL > 2^Depth-1 THEN COL=0
COLOR COL: LINE(16+2*I,131)-(17+2*I,139): NEXT
COLOR 1: LINE(44,131)-( 44,139)
' Cycle Draw
FOR I=1 TO 4: COL=I: IF COL > 2^Depth-1 THEN COL=0
COLOR COL: LINE(19+4*I,143)-(23+4*I,147): LINE(20+4*I,143)-(24+4*I,147)
LINE(21+4*I,143)-(25+4*I,147): LINE(22+4*I,143)-(26+4*I,147)
NEXT
' Display Foreground and Background Colors
LINE(22,151)-(33,159),COL,bf: LINE(34,151)-(44,159),LASTCOLOR,bf
' Menu items
MENU 1,0,1, "Project"
MENU 1,1,1, "New Painting"
MENU 1,2,1, "Load Brush "
MENU 1,3,1, "Load Painting"
MENU 1,4,1, "Save Brush "
MENU 1,5,1, "Save Painting"
MENU 1,6,1, "Quit "
MENU 2,0,0,"" : MENU 3,0,0,""
MENU 4,0,0,""
' Initialize starting values
TextX = 47: TextY = 8: NOBRUSH = TRUE :AdjOff = TRUE ' Mode Booleans
CycCl = FALSE: CycDr = FALSE : CSTOP = 2^Depth - 4 ' Cycling info
COL = 1 : LASTCOLOR = 0 : MaxColor = 2^Depth - 1 ' Color info
Style = 2: DY = Style - 1: DX = 2 * DY * RES2 ' Style info
GOSUB InitFile : GOSUB ResSel
l = MOUSE(0): X = MOUSE(1): Y = MOUSE(2):
' Main loop - always return here or at next statement
Main:
WHILE l<>0: l = MOUSE(0): WEND
Main2:
l = MOUSE(0):X = MOUSE(1):Y = MOUSE(2): Y=Y-1 'Fix Y to align better with pointer
IF MENU(0) THEN ON MENU(1) GOSUB NewPic, OpenBrush, Openfile, WriteBrush, Writefile, Quit
J = J + 1 : IF J > COLEnd THEN J = COLStart
IF CycCl THEN ' Cycle the colors
FOR I=COLStart TO COLEnd:PALETTE ((I+J) MOD CSpan)+COLStart, PCan!(I,0), PCan!(I,1), PCan!(I,2):NEXT
END IF
IF CycDr THEN ' Cycle the drawing color
COLOR J
END IF
IF X<0 OR X>WWIDTH OR Y<0 OR Y>HEIGHT GOTO Main2
IF X>46 THEN ' Paint in various Styles
IF Style <=4 THEN
GOSUB NBrush
ELSE
ON Style-4 GOSUB Brush,Dlines,DFill,DCircle,DBox,Dline,Dtext,AdjColor
END IF
GOTO Main2
END IF
' Select Color
IF l = 0 OR l = -1 THEN GOTO Main2
IF X<21 THEN GOSUB SelColor: GOTO Main2 'Color/style selection
' ---------------Erase Clear Save Load Exit Exit
' Select style
IF Y<120 THEN GOSUB SetStyle: GOTO Main2
' set/reset pattern
IF Y<130 THEN GOSUB PatSet: GOTO Main
' cycle the colors
IF Y<140 THEN GOSUB CycCol: GOTO Main
' cycle draw
IF Y<150 THEN GOSUB CycDraw: GOTO Main
GOTO Main
' ----------------- Subroutines -----------------
' Adjust the Red , Green , and Blue values for a color
' Toggle Color Adjuster on
AdjColor:
IF AdjOff THEN
BobRight = 223: BobBottom = 30
Size& = FNArraySize&\2: DIM SAVCOL&( Size&)
GET (58,50)-(281,80), SAVCOL&
GOSUB ColReq
AdjOff = FALSE
END IF
' If on end of slider, track with mouse, else move by steps
IF Y>51 AND Y<61 AND l<>0 THEN Gun=0
IF Y>61 AND Y<71 AND l<>0 THEN Gun=1
IF Y>71 AND Y<81 AND l<>0 THEN Gun=2
GOSUB Slider
RETURN
Slider:
TopS = Gun*10 + 52: BottomS = Gun*10 + 58
Slide = PCan!(COL,Gun)*15*14 + 60
WHILE l<>0 'Move slider to follow mouse
G1=(Slide-59)\14
IF X>Slide THEN LINE(60,TopS)-(Slide,BottomS),3,bf
IF X<Slide THEN LINE(Slide,TopS)-(270,BottomS),0,bf
PCan!(COL,Gun)=G1/15
IF Gun=0 THEN RED = G1
IF Gun=1 THEN GRN = G1
IF Gun=2 THEN BLU = G1
Slide=X
IF Slide < 61 THEN Slide = 61
IF Slide > 269 THEN Slide = 269
PALETTE COL, RED/15, GRN/15, BLU/15
l=MOUSE(0): X=MOUSE(1): Y=MOUSE(2)
WEND
RETURN
ColReq:
LINE (58,50)-(281,80),2,bf
CALL Move&( RP&, 273,58):PRINT "R"
CALL Move&( RP&, 273,68):PRINT "G"
CALL Move&( RP&, 273,78):PRINT "B"
l= MOUSE(0): X= MOUSE(1): Y= MOUSE(2)
RED = PCan!(COL,0)*15: GRN = PCan!(COL,1)*15: BLU = PCan!(COL,2)*15
LINE(58,50)-(271,60),1,b 'Box for R slider
LINE(60,52)-(RED*14+60,58),3,bf : LINE(RED*14+61,52)-(270,58),0,bf
LINE(58,60)-(271,70),1,b 'Box for G slider
LINE(60,62)-(GRN*14+60,68),3,bf : LINE(GRN*14+61,62)-(270,68),0,bf
LINE(58,70)-(271,80),1,b 'Box for B slider
LINE(60,72)-(BLU*14+60,78),3,bf : LINE(BLU*14+61,72)-(270,78),0,bf
RETURN
' Restore selection area
ResSel:
' Restore white borders for items selected
LINE(0,COLBOX*COL)-(20,COLBOX*(COL+1)),3,b
IF COL=3 THEN LINE(1,COLBOX*COL+1)-(19,COLBOX*(COL+1)-1),1,b
IF Style>0 THEN LINE(21,10*(Style-1))-(45,10*Style),3,b
IF Dotty THEN LINE(21,120)-(45,130),3,b
IF CycDr THEN LINE(21,140)-(45,150),3,b
LINE(22,151)-(33,159),COL,bf: LINE(34,151)-(44,159),LASTCOLOR,bf
COLOR COL, LASTCOLOR
RETURN
' Various brush widths
NBrush:
IF l = 0 THEN
LEFT = 47+ DX: IF X<LEFT THEN X=LEFT
TOP = 0 + DY: IF Y<TOP THEN Y=TOP
BOTTOM = HEIGHT-DY-1: IF Y>BOTTOM THEN Y=BOTTOM
RIGHT = WWIDTH-DX-1: IF X>RIGHT THEN X=RIGHT
X1= X: Y1= Y
ELSE
IF X<LEFT THEN X=LEFT
IF Y<TOP THEN Y=TOP
IF Y>BOTTOM THEN Y=BOTTOM
IF X>RIGHT THEN X=RIGHT
IF X+DX>46 THEN AREA(X1-DX,Y1+DY): AREA(X1+DX,Y1-DY): AREA(X+DX,Y-DY): AREA(X-DX,Y+DY): AREAFILL
X1= X: Y1=Y: l=MOUSE(0): X=MOUSE(1): Y=MOUSE(2): Y=Y-1:
END IF
RETURN
' Moveable line. Each DRAW complements (XORs) the current colors,
' so two DRAW's will restore the original. The same process
' is used for circles and rectangles in other routines
Dline:
IF l = 0 THEN RETURN
X1=X: Y1=Y: x2=X: y2=Y: CALL SetDrMd&( RP&, 2)
WHILE l<>0
LINE(X1,Y1)-(x2,y2): LINE(X1,Y1)-(x2,y2)
x2=X: y2=Y
l=MOUSE(0): X=MOUSE(1): Y=MOUSE(2): Y=Y-1: IF X<47 THEN X=47
WEND
' Finished - now reset DRAWMODE and draw the final line
CALL SetDrMd&( RP&, 1): LINE(X1,Y1)-(x2,y2)
RETURN
' Put text on bit map
Dtext:
C$= INKEY$: IF l = 0 AND C$="" THEN RETURN
IF l = 0 THEN
PRINT C$;
IF ASC(C$)=8 THEN TextX=TextX-8 ELSE TextX=TextX+8
IF TextX > WWIDTH THEN TextX = 47: TextY = TextY + 9
CALL Move&( RP&, TextX, TextY)
ELSE
TextX= X: TextY= Y
CALL Move&( RP&, TextX, TextY)
END IF
RETURN
' All lines from a point
Dlines:
IF l= 0 THEN
X1=X: Y1=Y
ELSE
LINE (X1,Y1)-(X,Y)
l=MOUSE(0): X=MOUSE(1): Y=MOUSE(2): Y=Y-1: IF X<47 THEN X=47
END IF
RETURN
' Custom Brush
Brush:
IF NOBRUSH THEN GOSUB NewBrush
IF l = 0 THEN
PUT( X,Y),BobArray,XOR: PUT( X,Y),BobArray,XOR
ELSE
PUT( X,Y),BobArray,PSET
END IF
RETURN
NewBrush:
IF l = 0 OR X < 47 THEN RETURN
X1=X: Y1=Y: x2=X: y2=Y: CALL SetDrMd&( RP&, 2)
WHILE l<>0
LINE(X1,Y1)-(x2,y2),,b: LINE(X1,Y1)-(x2,y2),,b
x2=X: y2=Y
l=MOUSE(0): X=MOUSE(1): Y=MOUSE(2) : Y=Y-1: IF X<47 THEN X=47
WEND
CALL SetDrMd&( RP&, 1)
NOBRUSH = FALSE
ERASE BobArray
BobRight = x2-X1: BobBottom = y2-Y1
ArraySize&=FNArraySize&
DIM BobArray(ArraySize&)
GET (X1,Y1)-(x2,y2),BobArray
RETURN
' Area color/pattern fill. Will not fill over a previously
' pattern-filled area. Line at X=46 keeps fill in working
' portion of screen and prevents bleeding into adjoining areas
DFill:
IF l=0 THEN RETURN
WHILE l<>0: l=MOUSE(0): WEND
IF COL=1 OR COL=3 THEN LINE(46,0)-(46,187),2
CALL Flood&( RP&, 1, X, Y)
IF COL=1 OR COL=3 THEN LINE(46,0)-(46,187),0
RETURN
' Variable sized circle. RES2 handles the x-y aspect
' ration for high res screens
DCircle:
IF l = 0 THEN RETURN
X1=X: Y1=Y: x2=X: y2=Y: R2=0 : R=0: CALL SetDrMd&( RP&, 2)
WHILE l<>0
R=SQR(((X1-X)/RES2)^2+(Y1-Y)^2)
IF X1-R*RES2<47 THEN R=(X1-47)/RES2 'Left limit of circle
CIRCLE(X1,Y1),R: CIRCLE(X1,Y1),R
x2=X: y2=Y: R2=R
l=MOUSE(0): X=MOUSE(1): Y=MOUSE(2) : Y=Y-1: IF X<47 THEN X=47
WEND
CALL SetDrMd&( RP&, 1): CIRCLE(X1,Y1),R2
RETURN
' Sizeable rectangle
DBox:
IF l = 0 THEN RETURN
X1=X: Y1=Y: x2=X: y2=Y: CALL SetDrMd&( RP&, 2)
WHILE l<>0
LINE(X1,Y1)-(x2,y2),,b: LINE(X1,Y1)-(x2,y2),,b
x2=X: y2=Y
l=MOUSE(0): X=MOUSE(1): Y=MOUSE(2) : Y=Y-1: IF X<47 THEN X=47
WEND
CALL SetDrMd&( RP&, 1): LINE(X1,Y1)-(x2,y2),,b
RETURN
' Clear the Screen
NewPic:
Prompt$ = " Press Return to New"
CANCEL=FALSE: GOSUB GetName ' get a filename
IF CANCEL THEN RETURN
FOR X=0 TO HEIGHT\2 'Add some pizazz to the clear
LINE(47+X,1+X)-(WWIDTH-X-1,HEIGHT-X),3,b
LINE(46+X,X)-(WWIDTH-X,HEIGHT-X),0,b
NEXT
GOSUB ResSel
RETURN
' Save info
' PENDING is used to restore screen if window is resized
' NOFILE is used in checking if the file already exists
' CANCEL is set if the user cancels the save operation
' OK=1 if the file already exists, =2 if OK to replace it
' PENDING=3: NOFILE=FALSE: CANCEL=FALSE: OK=0
'
' Load disk file
' PENDING=4: NOFILE=FALSE: CANCEL=FALSE
' File name requestor routine. We'll be looking for mouse
' clicks as well as character input, so use GET versus INPUT
' to receive the file name.
'
GetName:
BobRight = 190: BobBottom = 80
Size&=FNArraySize& \2
DIM SavReq&(Size&)
GET( 50,16)-(240,96), SavReq&
FOR I=0 TO 40 'Pop out the requestor box
LINE(90-I,56-I)-(200+I,56+I),2,b
NEXT
LINE(50,16)-(240,96),3,b
COLOR 1,2:CALL Move&(RP&,53,35): PRINT Prompt$;
LINE(69,50)-(218,62),3,b
' This little box is the "cursor", in yellow
CURS=72: LINE(CURS,52)-(CURS+7,60),3,bf
LINE(166,74)-(219,86),3,b
COLOR 3,1: CALL Move&(RP&, 169,83): PRINT "Cancel";
' Allowable file names (change it to suit your taste):
' First character must be a letter
' Remaining chars may be letters, numbers or . or -
' Maximum of 13 chars
' No two . or - may be adjoining
' No embedded blanks allowed
'
C$=INKEY$: WHILE C$<>"": C$=INKEY$: WEND 'Clear any queued input
FileName$=""
Loop:
C$=INKEY$: l=MOUSE(0): X=MOUSE(1):Y=MOUSE(2)
IF l<>0 THEN
WHILE l<>0: l=MOUSE(0): X=MOUSE(1):Y=MOUSE(2): WEND 'Wait for button release
' See if we're in the CANCEL box
Y=Y-1 'For better pointer alignment
IF X>165 AND X<220 AND Y>73 AND Y<87 THEN
CANCEL=TRUE: PUT(50,16),SavReq&,PSET: ERASE SavReq&: RETURN
END IF
END IF
IF C$="" THEN GOTO Loop
IF ASC(C$) = 13 THEN '13=Carriage return
PUT( 50,16),SavReq&,PSET: ERASE SavReq&: COLOR COL, LASTCOLOR
RETURN
END IF
IF ASC(C$) = 8 THEN '8=Backspace
IF LEN( FileName$) = 0 THEN GOTO Loop
FileName$=LEFT$(FileName$,LEN(FileName$)-1) 'Shorten name
LINE(CURS,52)-(CURS+7,60),2,bf 'Back up cursor
CURS=CURS-8: LINE(CURS,52)-(CURS+7,60),3,bf
GOTO Loop
END IF
IF LEN(FileName$) >= 17 GOTO Loop 'No more letters
IF RIGHT$(FileName$,1)="." OR RIGHT$(FileName$,1)="-" GOTO Loop
IF C$<" " OR C$>"z" GOTO Loop
' Add this letter and advance cursor
FileName$= FileName$ + C$
LINE(CURS,52)-(CURS+7,60),2,bf
COLOR 1,2: CALL Move&(RP&,CURS,59): PRINT C$;
CURS=CURS+8: LINE(CURS,52)-(CURS+7,60),3,bf
GOTO Loop 'Get another character
' Select a color
SelColor:
WHILE l <> 0: l=MOUSE(0): X=MOUSE(1): Y=MOUSE(2): WEND
IF X>21 THEN RETURN
' Erase white highlight around former color
LINE(0,COLBOX*COL)-(20,COLBOX*(COL+1)),1,b
IF COL=3 THEN LINE(1,COLBOX*COL+1)-(19,COLBOX*(COL+1)-1),3,b
I=COL: COL=Y\COLBOX
IF COL > MaxColor THEN COL = 0
' The previous color becomes the PENB color (for pattern)
IF I<>COL THEN LASTCOLOR=I
COLOR COL,LASTCOLOR
' Add white highlight around the new color
LINE(0,COLBOX*COL)-(20,COLBOX*(COL+1)),3,b
' Add an extra black highlight when color white is selected
IF COL=3 THEN LINE(1,COLBOX*COL+1)-(19,COLBOX*(COL+1)-1),1,b
' Show the foreground and background colors
LINE(22,151)-(33,159),COL,bf: LINE(34,151)-(44,159),LASTCOLOR,bf
IF Style = 12 THEN GOSUB ColReq
GOSUB SetSpan
FOR I=0 TO MaxColor: PALETTE I,PCan!(I,0),PCan!(I,1),PCan!(I,2): NEXT
COLOR COL,LASTCOLOR
RETURN
' Set style (and brush width, adjusted for resolution)
SetStyle:
WHILE l <> 0: l=MOUSE(0): X=MOUSE(1): Y=MOUSE(2): WEND
IF X<21 OR X>45 THEN RETURN
IF Style=5 AND (Y\10+1)=5 THEN NOBRUSH = TRUE
IF (Y\10+1) = Style THEN RETURN
IF Style>0 THEN LINE(21,10*(Style-1))-(45,10*Style),1,b
IF Style=12 THEN
PUT (58,50), SAVCOL&, PSET 'Clean up the screen
ERASE SAVCOL&
IF COL=0 THEN
FOR I=31 TO 2^Depth STEP -1: PALETTE I, PCan!(0,0), PCan!(0,1), PCan!(0,2):NEXT
END IF
AdjOff = TRUE
END IF
Style=Y\10+1
IF Style>0 THEN LINE(21,10*(Style-1))-(45,10*Style),3,b
DY=Style-1: DX=2*DY*RES2
RETURN
' Set/reset pattern. When pattern is in use, DOTTY=TRUE
PatSet:
IF Dotty THEN
Dotty=FALSE: PATTERN ,PAT1%
LINE(21,120)-(45,130),1,b
ELSE
LINE(21,120)-(45,130),3,b
Dotty=TRUE: PATTERN ,PAT2%
END IF
GOSUB ResSel
COLOR COL, LASTCOLOR
RETURN
' Cycle colors (except black, white and greys).
' This option can give the effect of movement
' (as may be noted in the selection box itself)
CycCol:
IF CycCl THEN
CycCl = FALSE
' -- restore the colors --
FOR I=0 TO MaxColor:PALETTE I, PCan!(I,0), PCan!(I,1), PCan!(I,2): NEXT
GOSUB ResSel
ELSE
CycCl = TRUE
GOSUB SetSpan
END IF
RETURN
CycDraw:
IF CycDr THEN
CycDr = FALSE
LINE (21,140)-(45,150),1,b
COLOR COL, LASTCOLOR
ELSE
CycDr = TRUE
LINE (21,140)-(45,150),3,b
GOSUB SetSpan
END IF
RETURN
SetSpan:
IF COL > LASTCOLOR THEN
COLStart = LASTCOLOR: COLEnd = COL
ELSE
COLStart = COL: COLEnd = LASTCOLOR
END IF
CSpan = COLEnd - COLStart + 1
RETURN
Quit:
Prompt$ = " Press Return to Quit"
CANCEL=FALSE: GOSUB GetName ' get a filename
IF CANCEL THEN RETURN
LIBRARY CLOSE
WINDOW CLOSE 2: SCREEN CLOSE 1
END
InitFile:
collisionPlaneIncluded=2 'never set by this editor
imageShadowIncluded=4 'never set by this editor
SAVEBACK=8 'save background before drawing BOB
OVERLAY=16 'color 0 for BOB is transparent, not black
SAVEBOB=32 'let BOB act like a paint brush
fVSprite = 0 'user can't edit sprite
FileName$=""
Flags=SAVEBACK+OVERLAY+fVSprite
BobRight= WWIDTH-1
BobBottom= HEIGHT-1
PlanePick= MaxColor
RETURN
OpenBrush:
NOBRUSH = FALSE
BrushLoad = TRUE
Prompt$ = " Enter Brush file name"
Openfile:
IF NOT BrushLoad THEN Prompt$ = "Enter Picture file name"
PENDING=4: CANCEL=FALSE: GOSUB GetName ' get a filename
IF FileName$<>"" AND (NOT CANCEL) THEN
OPEN FileName$ FOR INPUT AS 1 LEN=1024
olddepth = Depth
ColorSet=CVL(INPUT$(4,1))
DataSet=CVL(INPUT$(4,1))
Depth=CVL(INPUT$(4,1))
BobRight=CVL(INPUT$(4,1)) - 1
BobBottom=CVL(INPUT$(4,1)) - 1
REM --- UNDONE if ColorSet<>0 or DataSet<>0, read image.editor format file
Flags=CVI(INPUT$(2,1))
' IF Flags AND 1 THEN fVSprite = 1 ELSE fVSprite = 0
IF PlanePick < CVI(INPUT$(2,1)) THEN
COLOR 3,0:
LOCATE 3,8: PRINT "Error: file has more bit planes":
LOCATE 4,8: PRINT " than this screen has!"
COLOR COL,LASTCOLOR
ELSE
PlaneOnOff=CVI(INPUT$(2,1))
ERASE BobArray
ArraySize&=FNArraySize&
DIM BobArray(ArraySize&)
BobArray(0)=BobRight + 1
BobArray(1)=BobBottom + 1
BobArray(2)=Depth
FOR I=3 TO ArraySize&-1: BobArray(I)=CVI(INPUT$(2,1)):NEXT
IF NOT BrushLoad THEN GOSUB RedrawPicture
END IF
Depth = olddepth
CLOSE #1
END IF
PENDING = 0
BrushLoad = FALSE
RETURN
WriteBrush:
IF NOBRUSH THEN RETURN
BrushSave=TRUE
Prompt$ = " Enter Brush file name"
Writefile:
IF NOT BrushSave THEN Prompt$ = "Enter Picture file name"
PENDING=3: CANCEL=FALSE: GOSUB GetName 'get a filename
IF FileName$<>"" AND (NOT CANCEL) THEN
IF NOT BrushSave THEN GOSUB GetPicture
OPEN FileName$ FOR OUTPUT AS 1 LEN=1024
PRINT #1, MKL$(0); 'ColorSet
PRINT #1, MKL$(0); 'DataSet
PRINT #1, MKI$(0);MKI$(BobArray(2)); 'depth
PRINT #1, MKI$(0);MKI$(BobArray(0)); 'width
PRINT #1, MKI$(0);MKI$(BobArray(1)); 'height
PRINT #1, MKI$(Flags);
PRINT #1, MKI$(PlanePick); 'planePick
PRINT #1, MKI$(0); 'planeOnOff
FOR I=3 TO ArraySize&-1 : PRINT #1, MKI$(BobArray(I)); : NEXT
CLOSE#1
END IF
PENDING = 0
BrushSave = FALSE
RETURN
GetPicture:
BobRight = WWIDTH-1: BobBottom = HEIGHT-1
ArraySize&=FNArraySize&
ERASE BobArray
DIM BobArray(ArraySize&)
GET (47,0)-(BobRight,BobBottom),BobArray
RETURN
RedrawPicture:
PUT (47,0),BobArray,PSET
GOSUB ResSel 'redo the command box
ERASE BobArray
DIM BobArray(1)
RETURN